home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 001-010 / amok05 / memsystem / memsystem.mod < prev    next >
Text File  |  1993-11-04  |  5KB  |  169 lines
  1. (**********************************************************************
  2.  
  3.     :Program.       MemSystem.mod
  4.     :Contents.     Lowlevel System Support
  5.     :Author.        Nicolas Benezan [bne]
  6.     :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
  7.     :Phone.      711/333679
  8.     :Copyright.  Public Domain
  9.     :Language.      Modula-2
  10.     :Translator. M2Amiga AMSoft
  11.     :Imports.     IntuiStruct 1.0 [bne]
  12.     :ModHistory. V1.0b [bne] 17.06.88 (pre-version, private)
  13.     :ModHistory. V1.1d [bne] 09.07.88 (+ TaskMem)
  14.     
  15. **********************************************************************)
  16.  
  17. IMPLEMENTATION MODULE MemSystem;
  18.  
  19. FROM SYSTEM    IMPORT ADR,ADDRESS;
  20. FROM Exec    IMPORT AvailMem,MemReqSet,MemReqs,Forbid,Permit,
  21.         AddHead,Remove,MemList,MemEntry,Node,List,AllocEntry,
  22.                 FreeEntry,TaskPtr,FindTask;
  23. FROM ExecSupport IMPORT NewList;
  24. FROM Arts    IMPORT Assert,Terminate,CurrentLevel;
  25. FROM Intuition    IMPORT IDCMPFlagSet,IntuiText,AutoRequest;
  26. FROM Graphics    IMPORT jam1;
  27. FROM IntuiStruct IMPORT StructText;
  28.  
  29. CONST    NoIDCMP=IDCMPFlagSet{};
  30.         StdMinMem=20*1024;
  31.         StdHysteresis=30*1024;
  32.         ReqWidth=320;
  33.         ReqHeight=72;
  34.         ThisTask=NIL;
  35.         CHIP=MemReqSet{chip,memClear};
  36.         ANY=MemReqSet{memClear};
  37.  
  38. TYPE    TaskMemEntry=RECORD
  39.       memList:MemList;
  40.           memEntry:MemEntry;
  41.         END;
  42.         TaskMemEntryPtr=POINTER TO TaskMemEntry;
  43.  
  44. VAR    Header,Body,Positive,Negative:IntuiText;
  45.  
  46. PROCEDURE YesNoRequest(BodyText,PositiveText,NegativeText:ADDRESS;
  47.     PosFlags:IDCMPFlagSet;VAR Answer:BOOLEAN);
  48. BEGIN
  49.   Body.iText:=BodyText;
  50.   Positive.iText:=PositiveText;
  51.   Negative.iText:=NegativeText;
  52.   Answer:=AutoRequest(Window,ADR(Header),ADR(Positive),ADR(Negative),
  53.       PosFlags,NoIDCMP,ReqWidth,ReqHeight);
  54. END YesNoRequest;
  55.  
  56. PROCEDURE DeallocTaskMem(VAR Pointer:ADDRESS);
  57. VAR    Task:TaskPtr;
  58.     EntryPtr:TaskMemEntryPtr;
  59. BEGIN
  60.   Task:=FindTask(ThisTask);
  61.   EntryPtr:=ADDRESS(Task^.memEntry.head);
  62.   WHILE (EntryPtr^.memList.node.succ#NIL)
  63.      AND((EntryPtr^.memEntry.addr#Pointer)
  64.       OR(EntryPtr^.memList.numEntries#1)) DO
  65.     EntryPtr:=ADDRESS(EntryPtr^.memList.node.succ);
  66.   END;
  67.   Assert(EntryPtr^.memList.node.succ#NIL,ADR("can't Free() free Memory"));
  68.   Remove(ADDRESS(EntryPtr));
  69.   FreeEntry(ADDRESS(EntryPtr));
  70.   Pointer:=NIL;
  71. END DeallocTaskMem;
  72.  
  73. PROCEDURE AllocTaskMem(VAR Pointer:ADDRESS;Size:LONGINT;Reqs:MemReqSet);
  74. VAR    Task:TaskPtr;
  75.     Entry:TaskMemEntry;
  76.         EntryPtr:TaskMemEntryPtr;
  77.     Retry:BOOLEAN;
  78.  
  79.   PROCEDURE LowMemWarning;
  80.   BEGIN
  81.     YesNoRequest(ADR("Low memory warning"),ADR(RETRY),ADR(CANCEL),NoIDCMP,
  82.         Retry);
  83.   END LowMemWarning;
  84.  
  85. BEGIN
  86.   REPEAT
  87.     Forbid;
  88.     Task:=FindTask(ThisTask);
  89.     WITH Entry DO
  90.       memList.numEntries:=1;
  91.       memEntry.reqs:=Reqs;
  92.       memEntry.length:=Size;
  93.     END;
  94.     EntryPtr:=ADDRESS(AllocEntry(ADR(Entry)));
  95.     IF LONGINT(EntryPtr)<0 THEN
  96.       Pointer:=NIL;
  97.     ELSE
  98.       Pointer:=EntryPtr^.memEntry.addr;
  99.       AddHead(ADR(Task^.memEntry),ADDRESS(EntryPtr));
  100.     END;
  101.     IF Pointer=NIL THEN
  102.       Permit;
  103.       LowMemWarning;
  104.     ELSIF AvailMem(MemReqSet{chip,largest})<minMemory THEN
  105.       DeallocTaskMem(Pointer);
  106.       Permit;
  107.       LowMemWarning;
  108.     ELSE
  109.       Permit;
  110.     END;
  111.   UNTIL (Pointer#NIL)OR NOT Retry;
  112. END AllocTaskMem;
  113.  
  114. PROCEDURE Allocate(VAR Pointer:ADDRESS;Size:LONGINT);
  115. BEGIN
  116.   AllocTaskMem(Pointer,Size,ANY);
  117. END Allocate;
  118.  
  119. PROCEDURE AllocMem(VAR Pointer:ADDRESS;Size:LONGINT;Chip:BOOLEAN);
  120. VAR    ChipReq:MemReqSet;
  121. BEGIN
  122.   IF Chip THEN
  123.     ChipReq:=CHIP;
  124.   ELSE
  125.     ChipReq:=ANY;
  126.   END;
  127.   AllocTaskMem(Pointer,Size,ChipReq);
  128. END AllocMem;
  129.  
  130. PROCEDURE Deallocate(VAR Pointer:ADDRESS);
  131. BEGIN
  132.   DeallocTaskMem(Pointer);
  133. END Deallocate;
  134.  
  135. PROCEDURE ExitQuiet;
  136. BEGIN
  137.   Terminate(CurrentLevel());
  138. END ExitQuiet;
  139.  
  140. PROCEDURE RecoverableExit(ReqBody,PosText,NegText:ADDRESS);
  141. VAR    recover:BOOLEAN;
  142. BEGIN
  143.   YesNoRequest(ReqBody,PosText,NegText,NoIDCMP,recover);
  144.   IF NOT recover THEN
  145.     ExitQuiet;
  146.   END;
  147. END RecoverableExit;
  148.  
  149. PROCEDURE DeadEndExit(ReqBody:ADDRESS);
  150. VAR    Dummy:BOOLEAN;
  151. BEGIN
  152.   Body.iText:=ReqBody;
  153.   Negative.iText:=ADR(CANCEL);
  154.   Dummy:=AutoRequest(Window,ADR(Header),NIL,ADR(Negative),
  155.       NoIDCMP,NoIDCMP,ReqWidth,ReqHeight);
  156.   ExitQuiet;
  157. END DeadEndExit;
  158.  
  159. BEGIN
  160.   minMemory:=StdMinMem;
  161.   Hysteresis:=StdHysteresis;
  162.   Window:=NIL;
  163.   ErrHeader:="Modula-2 MemSystem";
  164.   StructText(Header,0,1,jam1,15,5,ADR(ErrHeader),ADR(Body));
  165.   StructText(Body,0,1,jam1,15,15,NIL,NIL);
  166.   StructText(Positive,0,1,jam1,6,3,NIL,NIL);
  167.   StructText(Negative,0,1,jam1,6,3,NIL,NIL);
  168. END MemSystem.
  169.